perm filename T3.F4[M11,LCS]2 blob
sn#396922 filedate 1978-11-22 generic text, type T, neo UTF8
00100 SUBROUTINE MSCAN(LL,W)
00200 DIMENSION W(1),TONES(21)
00300 COMMON /TR/I(80),RX(100),JX(100),LX(12),INST(27,5),MX5(40)
00400 1,INSNUM(27),P(30),NPAR(27),JSEM,IPRNT,IPP
00500 1,SRATE,RNCHN,RMAG,INUM,INS,MM,M,N,JJ,X,Y,IK
00600 1,ENDX,J /KNAM/KNAM,IPLAY,JFLNM,IOPEN
00700 COMMON /SBFILN/SBFILN /AR/IOP /IGEN/IGEN /JP/JPRNT,JWRT
00800 C OUT, OSC, AD2, RAN, ENV, STR, AD3, AD4, MLT, SET, RAH, GEN
00900 CXX DOUBLE PRECISION JFLNM
01000 INTEGER RPR
01100 EQUIVALENCE (LESS,LX(9)),
01200 1 (RX2,RX(3)),(P2,P(2)),(RX3,RX(5)),(I3,I(3))
01300 1 ,(ISEMI,LX(2)),(IAST,LX(3))
01400 1,(LPR,LX(11)),(RPR,LX(12)),(ICOM,LX(10)),(LAROW,LX(7))
01500 DATA TONES/246.945,261.62,277.18,277.8,293.66,311.13,311.13,
01600 1 329.63,349.23,329.63,349.23,369.99,369.99,
01700 1 391.99,415.31,415.31,440.0,466.16,466.16,493.89,523.24/
01800
01900 C**** CODE NUMS. 1=OUT 2=OSC 3=AD2 4=RAN 5=END 6=STR 7=AD3 8=AD4 9=MLT
02000 C**** 10=SET 11=RAH 12=END 13=INS 14=OPT B1=101 ETC. P1=201 ETC. F1=301 ETC.
02100 C**** 400=PLAY 401=FINI 402=SRATE 403=NCHNS 404=PRINT 405=CHA 406=POWER
02200 C**** 407=SRT 409=GEN 410=DUR 411=FREQ 412=INSTRUMENT 413=UNIT GEN.
02300 C**** 500=CF 501=C 502=CS 503=DF 504=D 505=DS 506=EF 507=E 508=ES 509=FF
02400 C**** 510=F 511=FS 512=GF 513=G 514=GS 515=AF 516=A 517=AS 518=BF 519=B 520=BS
02500
02600 30 IF(JSEM.NE.0)GO TO 34
02700 LL=1
02800 INS=-1
02900 34 J=J+2
03000 2324 FORMAT(1X20F10.3/)
03100 2325 FORMAT(1X20I/)
03200 2323 FORMAT(1X20A1/)
03300 IXJ=JX(J)
03400 IPP=0
03500 C!FOR 'P3←333;' ETC.
03600 IPOW=0
03700 IOP=-1
03800 IF(IXJ.NE.ISEMI)GO TO 9
03900 10 IF(IGEN.GT.100)W(3)=IGEN
04000 15 JSEM=-1
04100 RETURN
04200 9 IF(J.GE.MM)GO TO 1001
04300 IF(RX(J+1).EQ.-9999.0)GO TO 11
04400 C!*** SKIP IF NUMBER
04500 IF(IGEN.GT.0)GO TO 450
04600
04700 C!***** LOOK FOR SPECIAL WORDS
04800 IF(IXJ/400.NE.1)GO TO 32
04900 K=IXJ-399
05000 GO TO (3,13,304,303,302,303,4,505,505,422)K
05100 32 IF(IXJ.NE.13)GO TO 402
05200 C 13='INS'
05300 KNAM=IXJ
05400 W(1)=2
05500 IGEN=2
05600 GO TO 424
05700 505 JK=4
05800 C !**** FOR SRATE OR SRT
05900 IF(K.NE.4)JK=2
06000 JK=J+JK
06100 GO TO 304
06200
06300 450 K=IXJ
06400 C** HERE FOR INST DEFINITIONS.
06500 IF(K.LE.13.AND.K.GT.0)GO TO(425,425,425,425,425
06600 1,425,425,425,425,425,425,411),K
06700 IF(K.EQ.14)GO TO 425
06800 C 14='OPT' USER-ADDED UNIT GENERATOR.
06900 DO 451 JK=1,40,2
07000 C!*** FOR USER-ADDED UNIT GENS. (UP TO 20)
07100 IF(MX5(JK).NE.IXJ)GO TO 451
07200 W(3)=MX5(JK+1)
07300 GO TO 426
07400 451 CONTINUE
07500 CCC503 IF(JPRNT.LT.0)TYPE 504,IXJ
07600 503 JSEM=0
07700 J=MM
07800 RETURN
07900 504 FORMAT(' UNKNOWN SYMBOL ',A2)
08000 411 LL=3
08100 KNAM=IXJ
08200 IGEN=1
08300 C!*** =1 IS FLAG TO CHANGE IT TO -1
08400 J=MM
08500 INS=-1
08600 GO TO 10
08700 422 W(1)=3
08800 C!***** GEN
08900 KNAM=IXJ
09000 IGEN=0
09100 424 INS=-1
09200 LL=2
09300 GO TO 36
09400 425 W(3)=K+100
09500 426 KNAM=IXJ
09600 436 LL=4
09700 GO TO 36
09800
09900 3 J=J+2
10000 C !**** FOUND 'PLAY;'
10100 IF(JX(J).NE.ISEMI)CALL ERR(1)
10200 IPLAY=-1
10300 JSEM=-1
10400 IF(J.LT.MM)GO TO 34
10500 JSEM=0
10600 PAUSE 'BEFORE LABEL 4'
10700 RETURN
10800 4 JL=LL
10900 JOP=IOP
11000 J=J+2
11100 IF(JX(J).NE.LPR)CALL ERR(2)
11200 IPOW=-1
11300 IOP=-1
11400 GO TO 36
11500 C!**FIND NUM UP TO THE COMMA
11600 7 IF(IPOW.GT.0)GO TO 8
11700 IPOW=1
11800 GO TO 36
11900 8 LL=LL-2
12000 W(LL)=W(LL)**W(LL+1)
12100 IPOW=0
12200 IOP=JOP
12300 C!** GET BACK FLAGS
12400 GO TO 38
12500 302 LL=1
12600 IPRNT=-1
12700 C!***** FOR 'PRINT' FEATURE
12800 GO TO 36
12900 304 SRATE=RX(J+4)
13000 J=J+6
13100 RMAG=512./SRATE
13200 W(3)=4
13300 W(4)=SRATE
13400 351 W(1)=11
13500 W(2)=0
13600 IGEN=0
13700 LL=5
13800 GO TO 15
13900 CCC303 IF(IXJ.EQ.405)J=J-2
14000 303 RNCHN=RX(J+4)
14100 C!**** FOR NCHNS←N; OR CHA ← N;
14200 J=J+6
14300 CC IF(RX(JK+1).NE.-9999.0)JK=JK+2
14400 C!*** SKIP A COMMA
14500 CC IF(JX(JK+2).EQ.ISEMI)GO TO 352
14600 C!*** FOR NCHNS←n;
14700 352 W(3)=8
14800 C!*** FOR NCHNS
14900 W(4)=RNCHN-1
15000 GO TO 351
15100 35 IF(IPLAY.GE.0)CALL ERR(4)
15200 W(2)=INSNUM(IK)
15300 C!**** W IS P ARRAY IN MUSIC5
15400 LL=3
15500 C!**** W(2) AND W(3) WILL BE EXCHANGED LATER
15600 KNAM=IXJ
15700 36 J=J+2
15800 IF(J.GT.MM)GO TO 1001
15900 C!****** 50 = DONE
16000 CC JK=J*2
16100 IXJ=JX(J)
16200 CX TYPE 2324,RX(J+1)
16300 CX TYPE 2323,IXJ
16400 CX TYPE 2325,IXJ,IOP,IGEN
16500 CX PAUSE 'LABEL 36'
16600 IF(IXJ.NE.ISEMI)GO TO 1
16700 JSEM=-1
16800 1000 IF(IPP.EQ.0)GO TO 10
16900 P(IPP)=W(1)
17000 LL=1
17100 IPP=0
17200 IF(J.LT.MM)GO TO 30
17300 INS=-1
17400 C!*** I HOPE THIS IS THE RIGHT PLACE FOR THIS.
17500 1001 IF(IGEN.EQ.0.OR.JSEM.EQ.0)JSEM=1
17600 IF(JSEM)JSEM=0
17700 CX PAUSE 'LABEL 1001'
17800 RETURN
17900
18000 1 IF(RX(J+1).NE.-9999.0)GO TO 2
18100 CX TYPE 2325,IOP
18200 CX PAUSE 'LABEL 1'
18300 11 IF(IOP.LT.0)GO TO 40
18400 IF(IOP.NE.5)GO TO 12
18500 RX(J)=-RX(J)
18600 C!*** IOP=5 MEANS MINUS WITH COMMA IN FRONT
18700 W(LL)=RX(J)
18800 LL=LL+1
18900 GO TO 14
19000 12 CALL ARITH(RX(J),W,LL)
19100 14 IOP=-1
19200 C!*** RESET OPERATOR FLAG
19300 GO TO 36
19400 C!*** USE PARENTH'S FOR COMPOSITE EXPRESSIONS!!!!
19500
19600 40 W(LL)=RX(J)
19700 38 LL=LL+1
19800 IF(IOP.LT.0)GO TO 36
19900 C IOP = NEG = NO OPERATOR BEFORE THIS ITEM.
20000 LL=LL-1
20100 380 CALL ARITH(W(LL),W,LL)
20200 GO TO 14
20300
20400 402 IF(JSEM.GT.0)GO TO 2
20500 C!**** READING CONTINUATION LINE.
20600 IF(IXJ.GE.0)GO TO 33
20700 C NEXT TRIES TO FIND INST. NAME.
20800 NA=-1-IXJ
20900 M=JX(J+1)
21000 C NA POINTS TO SPOT IN I ARRAY, M IS WDCNT.
21100 DO 133 IK=1,INUM
21200 DO 233 II=1,M
21300 233 IF(INST(IK,II).NE.I(II+NA))GO TO 133
21400 C NOW WE FOUND AN INST. NAME.
21500 C******* INST NAMES CANNOT HAVE SAME STRING OF 1ST LETTERS AS OTHER THINGS.
21600 333 IF(M.EQ.5)GO TO 35
21700 M=M+1
21800 IF(INST(IK,M).EQ.0)GO TO 333
21900 133 CONTINUE
22000 33 INS=2
22100 C! NEXT IS SOMETHING OUTSIDE OF INST. AND PARAMS.
22200
22300 2 IF(IGEN.GT.0)GO TO 427
22400 IF(IXJ.GT.520)GO TO 341
22500 IF(IXJ.LT.500)GO TO 427
22600 C NOW FOUND A NOTE
22700 K=IXJ-499
22800 W(LL)=TONES(K)
22900 GO TO 38
23000 C!***** FINDS NOTE IN SCALE
23100
23200 C!****** FIND A PARAM NUM.
23300 427 IF(IXJ.GE.300)GO TO 307
23400 IF(IXJ.LT.200)GO TO 344
23500 K=IXJ-200
23600 C NOW K HAS PARAM NUM.
23700 IF(INS.LE.0)GO TO 340
23800 JK=J+2
23900 IF(JX(JK).NE.LAROW)GO TO 340
24000 IPP=K
24100 LL=1
24200 J=JK
24300 GO TO 36
24400 340 W(LL)=P(K)
24500 C!***** FOUND Pn
24600 IF(IPRNT.LT.0)GO TO 38
24700 IF(IGEN.GT.0)W(LL)=K+2.
24800 C!*** PARAM NUMS ARE 2 LESS THAN IN BOOK.
24900 GO TO 38
25000 C!**** P4 IS CHANGED TO 6
25100 307 IF(IXJ.GE.400)GO TO 344
25200
25300 IF(IXJ/300.NE.1)GO TO 344
25400 JL=IXJ-300
25500 IF(IGEN.GT.0)JL=-JL-100
25600 C!*** FOR Fn IN INST DEFINITION
25700 W(LL)=JL
25800 GO TO 38
25900 344 CONTINUE
26000
26100 IF(IGEN.LE.0)GO TO 341
26200 C*** FOR B1, ETC. IN INST. DEFS.
26300 IF(IXJ/100.NE.1)GO TO 341
26400 W(LL)=100-IXJ
26500 GO TO 38
26600 342 CONTINUE
26700
26800 341 DO 39 K=3,6
26900 IF(LX(K).NE.IXJ)GO TO 39
27000 IOP=K-2
27100 JK=JX(J-2)
27200 IF(JK.EQ.ICOM)IOP=5
27300 C!** COMMA DISABLES NEXT OPERATOR
27400 IF(JK.EQ.LAROW)IOP=5
27500 C!** ← DISABLES NEXT OPERATOR
27600 IF(JK.EQ.LPR)IOP=5
27700 C!** LFT PARENTH. DISABLES NEXT OPERATOR
27800 GO TO 36
27900 39 CONTINUE
28000 308 IF(IXJ.EQ.LAROW)GO TO 36
28100 C!*** PASS LEFT ARROW
28200 IF(IXJ.EQ.406)GO TO 4
28300 C 406='POWER'
28400 IF(IXJ.EQ.RPR)GO TO 500
28500 IF(IXJ.EQ.LPR)GO TO 500
28600 C LEFT AND RIGHT PARENTHESES
28700 IF(IXJ.NE.402)GO TO 510
28800 C 402=SRATE
28900 W(LL)=SRATE
29000 335 LL=LL+1
29100 GO TO 36
29200 C**** OR SHOULD NEXT BE 403???
29300 510 IF(IXJ.NE.403)GO TO 511
29400 C 403-'NCHNS'
29500 W(LL)=RNCHN
29600 GO TO 335
29700 511 IF(IXJ.NE.ICOM)GO TO 503
29800 C!***** UNKNOWN CHAR.
29900 500 IF(IPOW.NE.0)GO TO 7
30000 IF(IXJ.NE.LPR)GO TO 501
30100 JPOW=IPOW
30200 IPOW=0
30300 KOP=IOP
30400 IOP=-1
30500 JL=LL
30600 C!**** SAVE VARIOUS POINTERS WHEN INSIDE PARENTHS.
30700 GO TO 36
30800 501 IF(IXJ.NE.RPR)GO TO 502
30900 IPOW=JPOW
31000 C!*** GET BACK STUFF
31100 IOP=KOP
31200 IF(IOP.LT.0)GO TO 36
31300 LL=JL
31400 GO TO 380
31500 C!GO DO ARITHMETIC
31600 502 IF(IPRNT)GO TO 36
31700 C!**** FOUND COMMA IN PRINT STATEMENT.
31800 5 IF(JX(J-2).NE.ICOM)GO TO 132
31900 433 W(LL)=P(LL-2)
32000 C!** ONLY CARES ABOUT 2 COMMAS IN A ROW
32100 GO TO 335
32200 132 IF(INS.GE.0)GO TO 36
32300 IF(LL.EQ.3)GO TO 433
32400 C!*** =3 MEANS COMMA FOR P1.
32500 GO TO 36
32600
32700 13 LL=2
32800 IPLAY=0
32900 C!*** TURN OFF PLAY FLAG
33000 W(1)=6
33100 W(2)=ENDX+.5
33200 C!***** ENDX IS P1+P2 OF THE LONGEST LASTING INST.
33300 IF(JPRNT)TYPE 51,LL,W(1),W(2)
33400 IF(JWRT.GE.0)GO TO 130
33500 WRITE(21)LL,W(1),W(2)
33600 CZZ CALL CLOSE(1)
33700 END FILE(21)
33800 CXX CALL CLOSE(21)
33900 IOPEN=-1
34000 TYPE 131,JFLNM
34100 130 J=MM
34200 JSEM=99
34300 C!*** WON'T READ LINE BEYOND 'FINISH;' ***************
34400 ENDX=-1
34500 51 FORMAT(I3,35F10.3)
34600 131 FORMAT(9X,A4,'.DAT WAS WRITTEN *****')
34700 END
34800